home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / turbdir.pas < prev    next >
Pascal/Delphi Source File  |  1985-06-03  |  5KB  |  204 lines
  1. program dir;
  2.  
  3. {$i-,u-,c-}
  4.  
  5.    type
  6.      registers=record
  7.                  ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;
  8.                end;
  9.  
  10.      char80arr=array[1..80] of char;
  11.      string80=string[80];
  12.  
  13.    var
  14.      dta:array[1..43] of byte;
  15.      dtaseg,
  16.      dtaofs,
  17.      setdtaseg,
  18.      setdtaofs,
  19.      error,
  20.      i,j,
  21.      att,option:integer;
  22.      regs:registers;
  23.      buffer,
  24.      namr:string80;
  25.      mask:char80arr;
  26.  
  27. procedure setdta(segment,offset:integer;var error:integer);
  28.  
  29.   begin
  30.     regs.ax:=$1a00;
  31.     regs.ds:=segment;
  32.     regs.dx:=offset;
  33.     msdos(regs);
  34.     error:=regs.ax and $ff;
  35.   end;
  36.  
  37. procedure getcurrentdta(var segment,offset:integer; var error:integer);
  38.  
  39.   begin
  40.     regs.ax:=$2f00;
  41.     msdos(regs);
  42.     segment:=regs.es;
  43.     offset:=regs.bx;
  44.     error:=regs.ax and $ff;
  45.   end;
  46.  
  47. procedure getoption(var option:integer);
  48.   var
  49.     ch:char;
  50.  
  51.   begin
  52.     ch:='?';
  53.     option:=1;
  54.     while (ch='?') do
  55.       begin
  56.         write('File option to use, [?] for list :');
  57.         readln(ch);
  58.         writeln;
  59.         case(ch) of
  60.           '1':option :=1;
  61.           '2':option :=7;
  62.           '3':option :=8;
  63.           '4':option :=16;
  64.           '5':option :=22;
  65.           '6':option :=31;
  66.           '?':begin
  67.                 writeln('FIle options are : ');
  68.                 writeln;
  69.                 writeln('[1] for standard files [default].');
  70.                 writeln('[2] for system or hidden files');
  71.                 writeln('         and standard files');
  72.                 writeln('[3] for volume label');
  73.                 writeln('[4] for directories and standard files');
  74.                 writeln('[5] for directories,hidden or system');
  75.                 writeln('       files and standard files');
  76.                 writeln('[6] same as 5, but with volume');
  77.                 writeln('     label included');
  78.                 writeln;
  79.               end;
  80.           else
  81.             option :=1;
  82.          end; {case}
  83.     end;
  84.   end;
  85.  
  86. procedure getfirst(mask:char80arr;var namr:string80;segment,offset:integer;option:integer; var error:integer);
  87.  
  88.    var
  89.      i:integer;
  90.  
  91.   begin
  92.     error:=0;
  93.     regs.ax:=$4e00;
  94.     regs.ds:=seg(mask);
  95.     regs.dx:=ofs(mask);
  96.     regs.cx:=option;
  97.     msdos(regs);
  98.     error:=regs.ax and $ff;
  99.     i:=1;
  100.     repeat
  101.       namr[i]:=chr(mem[segment:offset+29+i]);
  102.       i:=i+1;
  103.     until (not(namr[i-1] in [' '..'~']));
  104.     att:=mem[segment:offset+21];
  105.     namr[0]:=chr(i-1);
  106.   end;
  107.  
  108. procedure getnextentry(var namr:string80; segment,offset:integer;
  109.                        option:integer;var error:integer);
  110.  
  111.   var
  112.     i:integer;
  113.  
  114.   begin
  115.     error:=0;
  116.     regs.ax:=$4f00;
  117.     regs.cx:=option;
  118.     msdos(regs);
  119.     error:=regs.ax and $ff;
  120.     i:=1;
  121.     repeat
  122.       namr[i]:=chr(mem[segment:offset+29+i]);
  123.       i:=i+1;
  124.     until (not(namr[i-1] in [' '..'~']));
  125.     att:=mem[segment:offset+21];
  126.     namr[0]:=chr(i-1);
  127.   end;
  128.  
  129. begin
  130.   for i:=1 to 21 do dta[i]:=0;
  131.   for i:=1 to 80 do
  132.     begin
  133.       mask[i]:=chr(0);
  134.       namr[i]:=chr(0);
  135.     end;
  136.   namr[0]:=chr(0);
  137.   writeln('QDL version @.0A');
  138.   writeln;
  139.   getcurrentdta(dtaseg,dtaofs,error);
  140.   if (error<>0 ) then
  141.     begin
  142.       writeln('unable to get current dta');
  143.       writeln('program aborting');
  144.       halt;
  145.     end;
  146.   setdtaseg:=seg(dta);
  147.   setdtaofs:=ofs(dta);
  148.   setdta(setdtaseg,setdtaofs,error);
  149.   if (error<>0) then
  150.     begin
  151.       writeln('Cannot reset dta');
  152.       writeln('Program aborting');
  153.       halt;
  154.     end;
  155.   error:=0;
  156.   buffer[0]:=chr(0);
  157.   getoption(option);
  158.   if (option<>8) then
  159.     begin
  160.       write('file mask :');
  161.       readln(buffer);
  162.       writeln;
  163.     end;
  164.   if (length(buffer)=0 ) then
  165.     buffer:='????????.???';
  166.   for i:=1 to length(buffer) do
  167.     mask[i]:=buffer[i];
  168.   getfirst(mask,namr,setdtaseg,setdtaofs,option,error);
  169.   if (error=0) then
  170.     begin
  171.       if (option <> 8) then
  172.         begin
  173.           writeln('Directory of : ',buffer);
  174.           writeln;
  175.         end;
  176.           if option<>16 then
  177.             writeln(namr)
  178.            else
  179.               if att=16 then
  180.                 writeln(namr);
  181.     end
  182.   else
  183.     if option=8 then
  184.       writeln('Volume label not found')
  185.      else
  186.        writeln('File ''', buffer, ''' not found.');
  187.   while (error=0) do
  188.     begin
  189.       getnextentry(namr,setdtaseg,setdtaofs,option,error);
  190.       if (error=0) then
  191.         begin
  192.           if option<>16 then
  193.             begin
  194.               write(namr);
  195.               if att=16 then writeln ('  <DIR>  ') else writeln
  196.             end
  197.            else
  198.               if att=16 then
  199.                 writeln(namr);
  200.         end;
  201.     end;
  202.   setdta(dtaseg,dtaofs,error);
  203. end.
  204.